home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Toolbox / Visual Basic Toolbox (P.I.E.)(1996).ISO / code_lib / objlibr / objlib12 / sample1 / chngicon.frm (.txt) next >
Encoding:
Visual Basic Form  |  1995-06-05  |  7.6 KB  |  269 lines
  1. VERSION 2.00
  2. Begin Form ChngIcon 
  3.    BackColor       =   &H00C0C0C0&
  4.    BorderStyle     =   3  'Fixed Double
  5.    Caption         =   "Change Icon"
  6.    ClientHeight    =   1845
  7.    ClientLeft      =   2310
  8.    ClientTop       =   2085
  9.    ClientWidth     =   6750
  10.    ControlBox      =   0   'False
  11.    Height          =   2250
  12.    Left            =   2250
  13.    LinkMode        =   1  'Source
  14.    LinkTopic       =   "Form1"
  15.    MaxButton       =   0   'False
  16.    MinButton       =   0   'False
  17.    ScaleHeight     =   123
  18.    ScaleMode       =   3  'Pixel
  19.    ScaleWidth      =   450
  20.    Top             =   1740
  21.    Width           =   6870
  22.    Begin PictureBox loader 
  23.       AutoRedraw      =   -1  'True
  24.       BorderStyle     =   0  'None
  25.       Height          =   495
  26.       Left            =   270
  27.       ScaleHeight     =   33
  28.       ScaleMode       =   3  'Pixel
  29.       ScaleWidth      =   33
  30.       TabIndex        =   9
  31.       Top             =   1620
  32.       Visible         =   0   'False
  33.       Width           =   495
  34.    End
  35.    Begin HScrollBar hs 
  36.       Height          =   252
  37.       LargeChange     =   288
  38.       Left            =   1680
  39.       SmallChange     =   36
  40.       TabIndex        =   7
  41.       Top             =   1215
  42.       Width           =   3492
  43.    End
  44.    Begin PictureBox Pic1 
  45.       BackColor       =   &H00FFFFFF&
  46.       Height          =   510
  47.       Left            =   1680
  48.       ScaleHeight     =   32
  49.       ScaleMode       =   3  'Pixel
  50.       ScaleWidth      =   230
  51.       TabIndex        =   6
  52.       Top             =   720
  53.       Width           =   3480
  54.       Begin PictureBox icns 
  55.          AutoRedraw      =   -1  'True
  56.          BackColor       =   &H00FFFFFF&
  57.          BorderStyle     =   0  'None
  58.          DrawWidth       =   2
  59.          Height          =   480
  60.          Left            =   0
  61.          ScaleHeight     =   32
  62.          ScaleMode       =   3  'Pixel
  63.          ScaleWidth      =   218
  64.          TabIndex        =   8
  65.          Top             =   0
  66.          Width           =   3264
  67.       End
  68.    End
  69.    Begin TextBox Text1 
  70.       FontBold        =   0   'False
  71.       FontItalic      =   0   'False
  72.       FontName        =   "MS Sans Serif"
  73.       FontSize        =   8.25
  74.       FontStrikethru  =   0   'False
  75.       FontUnderline   =   0   'False
  76.       Height          =   285
  77.       Left            =   1680
  78.       TabIndex        =   1
  79.       Text            =   "Text1"
  80.       Top             =   240
  81.       Width           =   3480
  82.    End
  83.    Begin CommandButton Command1 
  84.       BackColor       =   &H00000000&
  85.       Caption         =   "&Browse..."
  86.       Height          =   372
  87.       Index           =   2
  88.       Left            =   5400
  89.       TabIndex        =   5
  90.       Top             =   1200
  91.       Width           =   1092
  92.    End
  93.    Begin CommandButton Command1 
  94.       BackColor       =   &H00000000&
  95.       Cancel          =   -1  'True
  96.       Caption         =   "Cancel"
  97.       Height          =   372
  98.       Index           =   1
  99.       Left            =   5400
  100.       TabIndex        =   4
  101.       Top             =   720
  102.       Width           =   1092
  103.    End
  104.    Begin CommandButton Command1 
  105.       BackColor       =   &H00000000&
  106.       Caption         =   "OK"
  107.       Default         =   -1  'True
  108.       Height          =   372
  109.       Index           =   0
  110.       Left            =   5400
  111.       TabIndex        =   3
  112.       Top             =   240
  113.       Width           =   1092
  114.    End
  115.    Begin Image deficon 
  116.       Height          =   480
  117.       Left            =   900
  118.       Picture         =   CHNGICON.FRX:0000
  119.       Top             =   1650
  120.       Visible         =   0   'False
  121.       Width           =   480
  122.    End
  123.    Begin Label Label1 
  124.       Alignment       =   1  'Right Justify
  125.       AutoSize        =   -1  'True
  126.       BackColor       =   &H00C0C0C0&
  127.       BackStyle       =   0  'Transparent
  128.       Caption         =   "&Current Icon:"
  129.       Height          =   192
  130.       Index           =   1
  131.       Left            =   360
  132.       TabIndex        =   2
  133.       Top             =   720
  134.       Width           =   1128
  135.    End
  136.    Begin Label Label1 
  137.       Alignment       =   1  'Right Justify
  138.       AutoSize        =   -1  'True
  139.       BackStyle       =   0  'Transparent
  140.       Caption         =   "&Filename:"
  141.       Height          =   192
  142.       Index           =   0
  143.       Left            =   648
  144.       TabIndex        =   0
  145.       Top             =   264
  146.       Width           =   828
  147.    End
  148. Option Explicit
  149. DefInt A-Z
  150. Dim dirty%
  151. Dim iconindex%
  152. Dim i%, r%
  153. Dim lastvalidfile$
  154. 'This form is a copy of the PM dialog, but the method
  155. 'of hiliting the selected icon differs:
  156. 'When a file is selected and its icons are
  157. 'extracted, they are blitted to a picturebox
  158. 'as a bitmap. For simplicity, the selected icon
  159. 'is indicated by a black square rather than by
  160. 'changing the background color.
  161. Sub command1_click (Index As Integer)
  162. Dim f$
  163. Select Case Index
  164. Case 0'ok
  165.     'pass changes back to itemprops:
  166.     gItem.iconpath = text1
  167.     gItem.iconindex = iconindex
  168.     GetIcon gItem.iconpath, gItem.iconindex
  169.     Hide
  170. Case 1
  171.     Hide
  172. Case 2  'browse
  173.     f = GetFile(4, 4, 1): If f$ = "" Then Exit Sub
  174.     text1 = f$
  175.     LoadPics f$, 0
  176. End Select
  177. End Sub
  178. Function ExtractIcons (f As Form, file$)
  179. Dim n%, r%, inst%, i%, h%
  180. h% = f.hWnd
  181. inst% = GetWindowWord(h%, GWW_HINSTANCE)
  182. 'get total icons in file
  183. n% = ExtractIcon(inst%, file$, -1)
  184. If n < 1 Then
  185.     MsgBox "The file contains no icons.": Exit Function
  186. End If
  187. 'copy each to a bitmap
  188. screen.MousePointer = 11
  189. f.icns.Width = n * 36
  190. For i% = 0 To n - 1
  191.     GetIcon file$, i%
  192.     r = BitBlt(f.icns.hDC, i * 36 + 1, 1, 32, 32, loader.hDC, 0, 0, SRCCOPY)
  193. f.icns.Refresh
  194. ExtractIcons = n
  195. screen.MousePointer = 0
  196. End Function
  197. Sub Form_Load ()
  198. 'in case icon size changes with screen resolution:
  199. 'note: this hasn't been tested on anything but 1...x7..
  200.     Pic1.Move 112, 48, 6 * 36, 36
  201.     icns.Move 0, 0, Pic1.Width, 34
  202.     hs.Move Pic1.Left, Pic1.Top + Pic1.Height - 1, Pic1.Width
  203.     text1.Width = Pic1.Width
  204. text1 = Trim$(gItem.iconpath)
  205. If text1 = "" Then command1_click 2'prompt for file
  206. lastvalidfile$ = text1
  207. LoadPics gItem.iconpath, gItem.iconindex
  208. End Sub
  209. Sub Form_Paint ()
  210. RaiseForm Me
  211. End Sub
  212. Sub GetIcon (file$, ndx%)
  213. Dim h%, r%, inst%
  214. inst% = GetWindowWord(hWnd, GWW_HINSTANCE)
  215. h% = ExtractIcon(inst%, file$, ndx%)
  216. loader.Cls
  217. If h% > 1 Then 'has icons
  218.     r% = DrawIcon(loader.hDC, 0, 0, h%)
  219.     loader = deficon
  220. End If
  221. End Sub
  222. Sub hs_Change ()
  223. icns.Left = -hs.Value
  224. End Sub
  225. Sub icns_DblClick ()
  226. command1_click 0
  227. End Sub
  228. Sub icns_mousedown (Button As Integer, Shift As Integer, X As Single, Y As Single)
  229. 'erase old hilite
  230. icns.Line (iconindex * 36, 0)-(iconindex * 36 + 34, 34), icns.BackColor, B
  231. 'get absolute index
  232. iconindex = X \ 36
  233. 'draw new hilite
  234. icns.Line (iconindex * 36, 0)-(iconindex * 36 + 34, 34), &H0&, B
  235. End Sub
  236. Sub LoadPics (f$, ndx%)
  237. Dim total%
  238. If f = "" Then Exit Sub
  239. 'check path, then try to load icons
  240. If FileLen(f$) Then
  241.     lastvalidfile$ = f$
  242.     MsgBox "Cannot open file."
  243.     text1 = lastvalidfile$: Exit Sub
  244. End If
  245. 'copy file's icons to icns picbox
  246. total% = ExtractIcons(Me, f$)
  247. If total% = 0 Then Exit Sub
  248. 'set scroll range
  249. If total% > 8 Then
  250.     hs.Enabled = -1
  251.     hs.Max = (total - 8) * 36
  252.     hs.Enabled = 0
  253. End If
  254. 'hilite it
  255. iconindex = 0
  256. icns_mousedown 0, 0, ndx% * 36 + 3, 0
  257. End Sub
  258. Sub Text1_Change ()
  259. dirty = -1
  260. End Sub
  261. Sub Text1_GotFocus ()
  262. dirty = 0
  263. End Sub
  264. Sub Text1_LostFocus ()
  265. If dirty% Then
  266.         LoadPics CStr(text1), 0
  267. End If
  268. End Sub
  269.